home *** CD-ROM | disk | FTP | other *** search
/ MacGames Sampler / PHT MacGames Bundle.iso / MacSource Folder / Samples from the CD / Pascal / Source□ / Talk Source / My Libraries / MyLists.unit < prev    next >
Encoding:
Text File  |  1992-04-20  |  9.3 KB  |  370 lines  |  [TEXT/PJMM]
  1. unit MyLists;
  2.  
  3. { This program was written by Peter N Lewis, Mar 1992 in THINK Pascal 4.0.1 }
  4.  
  5. interface
  6.  
  7. { Some types have been changed to avoid clashing with the list manager }
  8.     type
  9.         listHead = ^listItemPtr;            { Was listHeadHandle }
  10.         listItem = ^listItemPtr;            { Was listHandle }
  11.         listItemPtr = ^listNode;            { Was listPtr }
  12.         listNode = record
  13.                 head: boolean;
  14.                 next: listItem;
  15.                 prev: listItem;
  16.                 this: handle;
  17.             end;
  18.  
  19.     var
  20.         listError: boolean;
  21.  
  22.     procedure CreateList (var l: listHead);
  23.     procedure DestroyList (var l: listHead; dispose: boolean);
  24.  
  25.     procedure ReturnHead (lh: listHead; var l: listItem);
  26.     (* <a> b c / <a> b c / <a> b c / <a> / <a> / <> *)
  27.     procedure ReturnTail (lh: listHead; var l: listItem);
  28.     (* a b c <> / a b c <> / a b c <> / a b c <> / a <> / a <> / <> *)
  29.  
  30.     procedure MoveToHead (var l: listItem);
  31.     (* <a> b c / <a> b c / <a> b c / <a> b c / <a> / <a> / <> *)
  32.     procedure MoveToTail (var l: listItem);
  33.     (* a b c <> / a b c <> / a b c <> / a b c <> / a <> / a <> / <> *)
  34.     procedure MoveToNext (var l: listItem);
  35.     (* a <b> c / a b <c> / a b c <> / error / a <> / error / error *)
  36.     procedure MoveToPrev (var l: listItem);
  37.     (* error / <a> b c / a <b> c / a b <c> / error / <a> / error *)
  38.  
  39.     function FindItem (lh: listHead; it: univ handle; var l: listItem): boolean;
  40.  
  41.     procedure AddHead (l: listHead; it: univ handle);
  42.     (* x <a> b c / x a <b> c / x a b <c> / x a b c <> / x <a> / x a <> / x <>*)
  43.     procedure AddTail (l: listHead; it: univ handle);
  44.     (* <a> b c x / a <b> c x / a b <c> x / a b c x <> / <a> x / a x <> / x <>*)
  45.     procedure AddBefore (l: listItem; it: univ handle);
  46.     (* x <a> b c / a x <b> c / a b x <c> / a b c x <> / x <a> / a x <> / x <>*)
  47.     procedure AddAfter (l: listItem; it: univ handle);
  48.     (* <a> x b c / a <b> x c / a b <c> x / error / <a> x / error / error *)
  49.  
  50.     procedure DeleteHead (l: listHead; var it: univ handle);
  51.     (* <?> b c / <b> c / b <c> / b c <> / <?> / <> / error *)
  52.     procedure DeleteTail (l: listHead; var it: univ handle);
  53.     (* <a> b / a <b> / a b <?> / a b <> / <?> / <> / error *)
  54.     procedure DeletePrev (l: listItem; var it: univ handle);
  55.     (* error / <b> c / a <c> / a b <> / error / <> / error *)
  56.     procedure DeleteNext (l: listItem; var it: univ handle);
  57.     (* <a> c / a <b> / error / error / error / error / error *)
  58.     procedure DeleteItem (var l: listItem; var it: univ handle);
  59.     (* <b> c / a <c> / a b <> / error / <> / error / error *)
  60.  
  61.     procedure FetchHead (l: listHead; var it: univ handle);
  62.     (* a / a / a / a / a / a / error  *)
  63.     procedure FetchTail (l: listHead; var it: univ handle);
  64.     (* c / c / c / c / a / a / error  *)
  65.     procedure FetchNext (l: listItem; var it: univ handle);
  66.     (* b / c / error / error / error / error / error *)
  67.     procedure FetchPrev (l: listItem; var it: univ handle);
  68.     (* error / a / b / c / error / a / error *)
  69.     procedure Fetch (l: listItem; var it: univ handle);
  70.     (* a / b / c / error / a / error / error *)
  71.  
  72.     function IsHead (l: listItem): boolean;
  73.     (* T / F / F / F / T / F / T *)
  74.     function IsTail (l: listItem): boolean;
  75.     (* F / F / F / T / F / T / T *)
  76.     function IsEmpty (l: listHead): boolean;
  77.     (* F / F / F / F / F / F / T *)
  78.  
  79.     procedure DisplayList (lh: listHead);
  80.    (* To the Text Screen *)
  81.  
  82. implementation
  83.  
  84. { Internal Routines }
  85.  
  86.     procedure DestroyListHandle (var l: univ listItem);
  87.     begin
  88. {    l^^.next := nil;                These dont do any good }
  89. {    l ^ ^ . prev := nil;            cause DisposHandle }
  90. {    l  ^ ^ . this := nil;            destroys the data }
  91.         DisposHandle(handle(l));
  92.         l := nil;
  93.     end;
  94.  
  95.     procedure CreateListHandle (var l: univ listItem);
  96.     begin
  97.         l := listItem(NewHandle(SizeOf(listNode)));
  98.     end;
  99.  
  100.     procedure MoveToStart (var l: univ listItem);
  101.         var
  102.             tmp: listItem;
  103.     begin
  104.         if not l^^.head then begin
  105.             tmp := l;
  106.             repeat
  107.                 l := l^^.next;
  108.             until (tmp = l) or l^^.head;
  109.             if tmp = l then
  110.                 listError := true;
  111.         end;
  112.     end;
  113.  
  114.     procedure InsertBefore (l: univ listItem; var it: univ handle);
  115.         var
  116.             tmp: listItem;
  117.     begin
  118.         CreateListHandle(tmp);
  119.         tmp^^.head := false;
  120.         tmp^^.this := it;
  121.         tmp^^.next := l;
  122.         tmp^^.prev := l^^.prev;
  123.         l^^.prev^^.next := tmp;
  124.         l^^.prev := tmp;
  125.     end;
  126.  
  127.     procedure DeleteNode (l: listItem; var it: univ handle);
  128.     begin
  129.         if l^^.head then
  130.             listError := true
  131.         else begin
  132.             it := l^^.this;
  133.             l^^.prev^^.next := l^^.next;
  134.             l^^.next^^.prev := l^^.prev;
  135.             DestroyListHandle(l);
  136.         end;
  137.     end;
  138.  
  139.     procedure FetchNode (l: listItem; var it: univ handle);
  140.     begin
  141.         if l^^.head then
  142.             listError := true;
  143.         it := l^^.this;
  144.     end;
  145.  
  146. { External Routines }
  147.  
  148.     procedure CreateList (var l: listHead);
  149.     begin
  150.         CreateListHandle(l);
  151.         l^^.head := true;
  152.         l^^.next := listItem(l);
  153.         l^^.prev := listItem(l);
  154.         l^^.this := nil;
  155.     end;
  156.  
  157.     procedure DestroyList (var l: listHead; dispose: boolean);
  158.         var
  159.             tmp, tmp2: listItem;
  160.     begin
  161.         tmp := l^^.next;
  162.         while tmp <> listItem(l) do begin
  163.             tmp2 := tmp;
  164.             tmp := tmp^^.next;
  165.             if dispose then
  166.                 DisposHandle(tmp2^^.this);
  167.             DestroyListHandle(tmp2);
  168.         end;
  169.         if dispose then
  170.             DisposHandle(l^^.this);
  171.         DestroyListHandle(l);
  172.     end;
  173.  
  174.     procedure ReturnHead (lh: listHead; var l: listItem);
  175.     (* <a> b c / <a> b c / <a> b c / <a> / <a> / <> *)
  176.     begin
  177.         l := lh^^.next;
  178.     end;
  179.  
  180.     procedure ReturnTail (lh: listHead; var l: listItem);
  181.     (* a b c <> / a b c <> / a b c <> / a b c <> / a <> / a <> / <> *)
  182.     begin
  183.         l := listItem(lh);
  184.     end;
  185.  
  186.     function FindItem (lh: listHead; it: univ handle; var l: listItem): boolean;
  187.     begin
  188.         l := listItem(lh)^^.next;
  189.         while (not l^^.head) and (it <> l^^.this) do
  190.             l := l^^.next;
  191.         FindItem := (not l^^.head) and (it = l^^.this);
  192.     end;
  193.  
  194.     procedure MoveToHead (var l: listItem);
  195.     (* <a> b c / <a> b c / <a> b c / <a> b c / <a> / <a> / <> *)
  196.     begin
  197.         MoveToStart(l);
  198.         l := l^^.next;
  199.     end;
  200.  
  201.     procedure MoveToTail (var l: listItem);
  202.     (* a b c <> / a b c <> / a b c <> / a b c <> / a <> / a <> / <> *)
  203.     begin
  204.         MoveToStart(l);
  205.     end;
  206.  
  207.     procedure MoveToNext (var l: listItem);
  208.     (* a <b> c / a b <c> / a b c <> / error / a <> / error / error *)
  209.     begin
  210.         if l^^.head then
  211.             listError := true
  212.         else
  213.             l := l^^.next;
  214.     end;
  215.  
  216.     procedure MoveToPrev (var l: listItem);
  217.     (* error / <a> b c / a <b> c / a b <c> / error / <a> / error *)
  218.     begin
  219.         if l^^.prev^^.head then
  220.             listError := true
  221.         else
  222.             l := l^^.prev;
  223.     end;
  224.  
  225.     procedure AddHead (l: listHead; it: univ handle);
  226.     (* x <a> b c / x a <b> c / x a b <c> / x a b c <> / x <a> / x a <> / x <>*)
  227.     begin
  228.         InsertBefore(l^^.next, it);
  229.     end;
  230.  
  231.     procedure AddTail (l: listHead; it: univ handle);
  232.     (* <a> b c x / a <b> c x / a b <c> x / a b c x <> / <a> x / a x <> / x <>*)
  233.     begin
  234.         InsertBefore(l, it);
  235.     end;
  236.  
  237.     procedure AddBefore (l: listItem; it: univ handle);
  238.     (* x <a> b c / a x <b> c / a b x <c> / a b c x <> / x <a> / a x <> / x <>*)
  239.     begin
  240.         InsertBefore(l, it);
  241.     end;
  242.  
  243.     procedure AddAfter (l: listItem; it: univ handle);
  244.     (* <a> x b c / a <b> x c / a b <c> x / error / <a> x / error / error *)
  245.     begin
  246.         if l^^.head then
  247.             listError := true
  248.         else
  249.             InsertBefore(l^^.next, it);
  250.     end;
  251.  
  252.     procedure DeleteHead (l: listHead; var it: univ handle);
  253.     (* <?> b c / <b> c / b <c> / b c <> / <?> / <> / error *)
  254.     begin
  255.         DeleteNode(l^^.next, it);
  256.     end;
  257.  
  258.     procedure DeleteTail (l: listHead; var it: univ handle);
  259.     (* <a> b / a <b> / a b <?> / a b <> / <?> / <> / error *)
  260.     begin
  261.         DeleteNode(l^^.prev, it);
  262.     end;
  263.  
  264.     procedure DeletePrev (l: listItem; var it: univ handle);
  265.     (* error / <b> c / a <c> / a b <> / error / <> / error *)
  266.         var
  267.             tmp: listItem;
  268.     begin
  269.         DeleteNode(l^^.prev, it);
  270.     end;
  271.  
  272.     procedure DeleteNext (l: listItem; var it: univ handle);
  273.     (* <a> c / a <b> / error / error / error / error / error *)
  274.     begin
  275.         if l^^.head then begin
  276.             listError := true;
  277.             it := nil;
  278.         end
  279.         else
  280.             DeleteNode(l^^.next, it);
  281.     end;
  282.  
  283.     procedure DeleteItem (var l: listItem; var it: univ handle);
  284.     (* <b> c / a <c> / a b <> / error / <> / error / error *)
  285.         var
  286.             tmp: listItem;
  287.     begin
  288.         if l^^.head then begin
  289.             listError := true;
  290.             it := nil;
  291.         end
  292.         else begin
  293.             tmp := l^^.next;
  294.             DeleteNode(l, it);
  295.             l := tmp;
  296.         end;
  297.     end;
  298.  
  299.     procedure FetchHead (l: listHead; var it: univ handle);
  300.     (* a / a / a / a / a / a / error  *)
  301.     begin
  302.         FetchNode(l^^.next, it);
  303.     end;
  304.  
  305.     procedure FetchTail (l: listHead; var it: univ handle);
  306.     (* c / c / c / c / a / a / error  *)
  307.     begin
  308.         FetchNode(l^^.prev, it);
  309.     end;
  310.  
  311.     procedure FetchNext (l: listItem; var it: univ handle);
  312.     (* b / c / error / error / error / error / error *)
  313.     begin
  314.         if l^^.head then begin
  315.             listError := true;
  316.             it := nil;
  317.         end
  318.         else
  319.             FetchNode(l^^.next, it);
  320.     end;
  321.  
  322.     procedure FetchPrev (l: listItem; var it: univ handle);
  323.     (* error / a / b / c / error / a / error *)
  324.     begin
  325.         FetchNode(l^^.prev, it);
  326.     end;
  327.  
  328.     procedure Fetch (l: listItem; var it: univ handle);
  329.     (* a / b / c / error / a / error / error *)
  330.     begin
  331.         FetchNode(l, it);
  332.     end;
  333.  
  334.     function IsHead (l: listItem): boolean;
  335.     (* T / F / F / F / T / F / T *)
  336.     begin
  337.         IsHead := l^^.prev^^.head;
  338.     end;
  339.  
  340.     function IsTail (l: listItem): boolean;
  341.     (* F / F / F / T / F / T / T *)
  342.     begin
  343.         IsTail := l^^.head;
  344.     end;
  345.  
  346.     function IsEmpty (l: listHead): boolean;
  347.     (* F / F / F / F / F / F / T *)
  348.     begin
  349.         IsEmpty := l^^.next = listItem(l);
  350.     end;
  351.  
  352.     procedure DisplayList (lh: listHead);
  353.         var
  354.             l: listItem;
  355.             h: longInt;
  356.     begin
  357.         ShowText;
  358.         ReturnHead(lh, l);
  359.         write('(');
  360.         while not IsTail(l) do begin
  361.             Fetch(l, h);
  362.             MoveToNext(l);
  363.             write(h : 1);
  364.             if not IsTail(l) then
  365.                 write(',');
  366.         end;
  367.         writeln('  )');
  368.     end;
  369.  
  370. end.